home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Choicebox.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  2.7 KB  |  86 lines
  1. ;;;;
  2. ;;;; C h o i c e b o x . s t k       --  Choice Box composite widget
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  15. ;;;;    Creation date: 22-Mar-1994 13:05
  16. ;;;; Last file update:  2-Jul-1996 12:06
  17.  
  18.  
  19. (require "Tk-classes")
  20.  
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22. ;;;;
  23. ;;;; <Choice-box> class definition
  24. ;;;;
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26.  
  27. (define-class <Choice-box> (<Tk-composite-widget> <Labeled-Entry>)
  28.   ((lentry      :accessor   lentry-of)
  29.    (menu     :accessor   menu-of)
  30.    (menubutton   :accessor   menubutton-of)
  31.    ;; Non allocated slots
  32.    (background   :accessor     background
  33.          :init-keyword :background
  34.          :allocation   :propagated
  35.          :propagate-to (frame lentry menu menubutton))
  36.    (border-width :accessor     border-width 
  37.          :allocation   :propagated
  38.          :init-keyword :border-width
  39.          :propagate-to (frame))
  40.    (relief     :accessor     relief
  41.          :init-keyword :relief
  42.          :allocation   :propagated
  43.          :propagate-to (frame))))
  44.  
  45. ;;;;
  46. ;;;; <Choice-box> methods
  47. ;;;;
  48.  
  49. (define-method initialize-composite-widget ((self <Choice-box>) initargs parent)
  50.   (let* ((l  (make <Labeled-entry> :parent parent))
  51.      (mb (make <Menu-button>   :parent parent
  52.                       :text ""
  53.                    :relief "flat"
  54.                       :indicator-on #t
  55.                       :relief "raised"))
  56.      (m  (make <Menu>          :parent mb)))
  57.  
  58.     (pack l  :side "left"  :fill "x" :expand #t)
  59.     (pack mb :side "right")
  60.     
  61.     ;; Initialize true slots
  62.     (slot-set! self 'Id        (slot-ref l 'Id))
  63.     (slot-set! self 'lentry l)
  64.     (slot-set! self 'menu   m)
  65.     (slot-set! self 'menubutton mb)
  66.  
  67.     ;; Initialize inherited slots
  68.     (slot-set! self 'label  (label-of l))
  69.     (slot-set! self 'entry  (entry-of l))
  70.  
  71.     ;; Attach menu m to menu button mb
  72.     (set! (menu-of mb) m)))
  73.  
  74. ;;
  75. ;; add-choice permits to add a new choice (a string) in the associated 
  76. ;; Choice-box menu
  77. ;;
  78.  
  79. (define-method add-choice ((self <Choice-box>) mess)
  80.   (menu-add (Menu-of self) 'command 
  81.                    :label mess 
  82.                :command (lambda () 
  83.                       (set! (value self) mess))))
  84.  
  85. (provide "Choicebox")
  86.